(define (uaraa:analyze-parameter-access! prog types)
  (define types-modified? #f)
  (define (collect-acc-prog!)
    (for-each
      (lambda (fundef)
        (let ((body (cadddr fundef))
              (parlist (cadr fundef))
              (fname (car fundef)))
          (collect-acc-exp! body '() fname parlist)))
      prog))
  (define (collect-acc-exp! exp context fn vn)
    (cond ((symbol? exp)
           (if (not (null? context))
             (begin (contract-var! exp context fn vn))))
          ((equal? (car exp) 'quote) #f)
          ((equal? (car exp) 'car)
           (let ((exp1 (cadr exp)))
             (collect-acc-exp! exp1 `(car unquote context) fn vn)))
          ((equal? (car exp) 'cdr)
           (let ((exp1 (cadr exp)))
             (collect-acc-exp! exp1 `(cdr unquote context) fn vn)))
          ((equal? (car exp) 'cons)
           (let ((exp2 (caddr exp)) (exp1 (cadr exp)))
             (collect-acc-exp! exp1 (un-car context) fn vn)
             (collect-acc-exp! exp2 (un-cdr context) fn vn)))
          ((equal? (car exp) 'call)
           (let ((exp* (cddr exp)) (fname (cadr exp)))
             (let ((%%74 (assq fname types)))
               (let ((arg-type* (cdr %%74)))
                 (collect-acc-arg*! exp* arg-type* fn vn)))))
          ((equal? (car exp) 'xcall)
           (let ((exp* (cddr exp)) (fname (cadr exp)))
             (collect-acc-exp*! exp* fn vn)))
          (else
           (let ((exp* (cdr exp)) (op (car exp)))
             (collect-acc-exp*! exp* fn vn)))))
  (define (collect-acc-exp*! exp* fn vn)
    (for-each (lambda (exp) (collect-acc-exp! exp '() fn vn)) exp*))
  (define (collect-acc-arg*! exp* patt* fn vn)
    (for-each
      (lambda (exp patt) (collect-acc-exp! exp (patt->context patt) fn vn))
      exp*
      patt*))
  (define (update-types! func)
    (for-each
      (lambda (fdescr)
        (let ((type* (cdr fdescr)) (fname (car fdescr)))
          (set-cdr! fdescr (map func type*))))
      types))
  (define (mark-conses type)
    (cond ((equal? type 'absent) 'any)
          ((equal? type 'any) type)
          ((equal? (car type) 'atom) type)
          ((equal? (car type) 'cons)
           (let ((t2 (caddr type)) (t1 (cadr type)))
             `(cons? ,(mark-conses t1) ,(mark-conses t2))))
          (else (error "SELECT: no match for" type))))
  (define (generalize-type type)
    (cond ((equal? type 'any) type)
          ((equal? (car type) 'atom) type)
          ((equal? (car type) 'cons)
           (let ((t2 (caddr type)) (t1 (cadr type)))
             `(cons ,(generalize-type t1) ,(generalize-type t2))))
          ((equal? (car type) 'cons?) 'any)
          (else (error "SELECT: no match for" type))))
  (define (patt->context patt)
    (cond ((equal? patt 'any) '())
          ((equal? (car patt) 'atom) '())
          ((equal? (car patt) 'cons) patt)
          ((equal? (car patt) 'cons?) '())
          (else (error "SELECT: no match for" patt))))
  (define (un-car context)
    (cond ((null? context) '())
          ((equal? (car context) 'car) (let ((rest (cdr context))) rest))
          ((equal? (car context) 'cdr) (let ((rest (cdr context))) '()))
          ((equal? (car context) 'cons)
           (let ((p2 (caddr context)) (p1 (cadr context))) (patt->context p1)))
          (else (error "SELECT: no match for" context))))
  (define (un-cdr context)
    (cond ((null? context) '())
          ((equal? (car context) 'car) (let ((rest (cdr context))) '()))
          ((equal? (car context) 'cdr) (let ((rest (cdr context))) rest))
          ((equal? (car context) 'cons)
           (let ((p2 (caddr context)) (p1 (cadr context))) (patt->context p2)))
          (else (error "SELECT: no match for" context))))
  (define (contract-var! vname context fname vn)
    (let ((%%75 (assq fname types)))
      (let ((fdescr %%75))
        (let ((type* (cdr fdescr)))
          (set-cdr! fdescr (contract-par context vname vn type*))))))
  (define (contract-par context par vname* type*)
    (let ((r-vname* (cdr vname*)) (vname (car vname*)))
      (let ((r-type* (cdr type*)) (type (car type*)))
        (if (eq? par vname)
          `(,(contract-type context type) unquote r-type*)
          `(,type unquote (contract-par context par r-vname* r-type*))))))
  (define (contract-type context type)
    (cond ((null? context) type)
          ((equal? (car context) 'car)
           (let ((rest (cdr context)))
             (cond ((equal? type 'any) type)
                   ((equal? (car type) 'atom) type)
                   ((equal? (car type) 'cons)
                    (let ((t2 (caddr type)) (t1 (cadr type)))
                      `(cons ,(contract-type rest t1) ,t2)))
                   ((equal? (car type) 'cons?)
                    (let ((t2 (caddr type)) (t1 (cadr type)))
                      `(cons ,(contract-type rest t1) ,t2)))
                   (else (error "SELECT: no match for" type)))))
          ((equal? (car context) 'cdr)
           (let ((rest (cdr context)))
             (cond ((equal? type 'any) type)
                   ((equal? (car type) 'atom) type)
                   ((equal? (car type) 'cons)
                    (let ((t2 (caddr type)) (t1 (cadr type)))
                      `(cons ,t1 ,(contract-type rest t2))))
                   ((equal? (car type) 'cons?)
                    (let ((t2 (caddr type)) (t1 (cadr type)))
                      `(cons ,t1 ,(contract-type rest t2))))
                   (else (error "SELECT: no match for" type)))))
          (else (let ((patt context)) (match-types patt type)))))
  (define (match-types patt type)
    (cond ((equal? patt 'any) type)
          ((equal? (car patt) 'atom) type)
          ((equal? (car patt) 'cons)
           (let ((p2 (caddr patt)) (p1 (cadr patt)))
             (cond ((equal? type 'any) type)
                   ((equal? (car type) 'atom) type)
                   ((equal? (car type) 'cons)
                    (let ((t2 (caddr type)) (t1 (cadr type)))
                      `(cons ,(match-types p1 t1) ,(match-types p2 t2))))
                   ((equal? (car type) 'cons?)
                    (let ((t2 (caddr type)) (t1 (cadr type)))
                      `(cons ,(match-types p1 t1) ,(match-types p2 t2))))
                   (else (error "SELECT: no match for" type)))))
          ((equal? (car patt) 'cons?) type)
          (else (error "SELECT: no match for" patt))))
  (update-types! mark-conses)
  (let recalc-accesses! ()
    (display "*")
    (set! types-modified? #f)
    (collect-acc-prog!)
    (if types-modified? (recalc-accesses!) (update-types! generalize-type))))

